Developer CD Series 1996 May: Tool Chest/Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso/Tool Chest/Development Tools & Languages/Macintosh Common Lisp Related/User Contributions/dm Folder.sea/dm Folder/dungeon-master.lisp

Text File | 1993-02-12 | 37.0 KB | 1,112 lines | [TEXT/CCL2]

;;; -*- Mode: Lisp; Package: DUNGEON-MASTER; -*-

;;; $Header: /afs/athena.mit.edu/course/other/allp/nlp/tools/RCS/dungeon-master.lisp,v 3.2 92/07/08 16:29:09 sfelshin Exp $

;;; ================================================================
;;;
;;;                The Dungeon Master
;;;
;;;               An alternative module system
;;;
;;;                Version 1.0
;;;
;;;                Source code
;;;
;;; ================================================================

;;; Copyright (c) 1986-90, 1992-93 Massachusetts Institute of Technology.
;;; Permission is granted to use this software and to pass on copies,
;;; provided that this copyright notice is retained intact.  In addition,
;;; permission is granted to modify this software, provided all changes are
;;; prominently marked.  For more details, refer to the accompanying file
;;; "dm-copyright.text".

;;; Brought to you by the Laboratory for Advanced Technology in the
;;; Humantities (formerly the Athena Language Learning Project) at MIT.
;;; "Bigger!  Better!  Slower!"

;;; Software by Sue Felshin and Stuart Malone.  Documentation by Sue
;;; Felshin.

;;; The Dungeon Master system consists of six files:
;;;   1) source code ("dungeon-master.lisp"),
;;;   2) a detailed copyright notice ("dm-copyright.text"),
;;;   3) user documentation in mss (Scribe) format ("dm.mss"),
;;;   4) PostScript format ("dm.text"), and
;;;   5) text format, and
;;;   6) examples of using the Dungeon Master ("dm-use.lisp").
;;; This is file number 1.

;;; If you improve the Dungeon Master, you are encouraged to mail changes
;;; to [e-mail].

;;; This software has been tested with Lucid Common Lisp 4.0.0 and MCL
;;; 2.0f.  It should also work with MCL 1.[whatever the last version was].
;;; It will _not_ work with MCL2.0b unless you modify the code to use the
;;; public domain pretty printer.  A slightly older version of this code
;;; was tested with version of Lucid (1.01) on RTs.

;;; This file has three parts.  First, it defines a new package and defines
;;; some extensions to Common Lisp's file system interface.  Then it
;;; defines some code to make it easier to deal with mutually-dependent
;;; packages, and ensures that the pretty printer and condition system are
;;; available if needed, even in non-fully-CLtL2-compatible Common Lisps.
;;; Finally, it defines the Dungeon Master, an extended module system.  The
;;; Dungeon Master is an extension of the module system described in
;;; Section 11.8 of CLtL1, but is incompatible with that system to the
;;; extent that it requires a one-to-one correspondence between modules and
;;; files.

;;; This file defines a module system.  It is not itself a module.

;;; To configure the Dungeon Master for an as-yet-unsupported
;;; configuration, search for calls to CONFIGURE-ME-ERROR in this file.
;;; Add the appropriate code for your lisp.  In some cases this will
;;; consist merely of adding your lisp's distinguishing feature(s) to an
;;; existing #+ form and subtracting them from the associated error form.
;;; In other cases, you will have to add a small amount of code.  After you
;;; have configured your lisp, please send your changes to
;;; [e-mail] so that they can be integrated into the
;;; official cody of the Dungeon Master.


;;; ================================================================
;;;
;;;                Part the First.
;;;
;;;
;;;        In which we create a new package and extend
;;;           Common Lisp's file system interface.
;;;
;;; ================================================================

;;; This code was written in the days of CLtL1, before Common Lisp had
;;; specifications for case conversion, structured directories, extended
;;; wildcards, and logical pathnames.  Much of the code in this section
;;; could be eliminated by making use of these new features of CLtL2.


;;; Many lisps will complain, upon loading this file, that the file does
;;; not begin with an IN-PACKAGE statement.  This is quite proper.  After
;;; we have defined a package, we will switch to it.


;;; ================================
;;; Define a new package because is an error to add external symbols to the
;;; Common Lisp package.

(eval-when (eval load compile)
  (or (find-package :dm)
      (make-package :dm
    ;; CLtL2, p 263: "... the default value for the :USE argument is
    ;; unspecified.  Portable code should specify :USE '("COMMON-LISP")
    ;; explicitly.
    :use '(#-lucid "COMMON-LISP"
           ;; Lucid Common Lisp is not 100% CLtL2 compatible yet.
           #+lucid "LISP" #+lucid "LUCID-COMMON-LISP"))))

(in-package :dm)

(eval-when (eval load compile)
  (export '(search-for-file find-module-file push-module-search-path
        mload mcomp load-modules compile-modules
        provide-module require-module unprovide-module
        mload-protect uncompiled-modules modules-dependent-on)
      :allp))


;;; =====================================
;;; Define some useful pathname functions.

(defun configure-me-error ()
  (error "The Dungeon Master needs to be configured for this Lisp."))

;;; Add the AIX feature to Lucid on the RT under AIX, which normally doesn't
;;; have one.
#+(and lucid (not rios) (not ultrix) (not ps2)) (pushnew :aix *features*)

(defparameter *lsp-type*
  #+(and lucid aix (not rios)) "l"
  #+(and lucid rios) "lisp"
  #+:ccl "lisp"
  #+ultrix "lisp"
  #+(not (or (and lucid aix (not rios)) (and lucid rios) :ccl ultrix))
  (configure-me-error))

(defparameter *fas-type*
  #+(and lucid aix (not rios)) "b"
  #+(and lucid rios lcl4.0) "rbin"
  #+(and lucid ps2) "3bin"        ;Really should check version of Lucid?
  #+:ccl "fasl"
  #+ultrix "mbin"
  #-(or (and lucid aix (not rios)) (and lucid rios) :ccl ultrix)
  (configure-me-error))

(defun push-directory (dir path)
  (make-pathname
    :directory
      #+lucid (append (pathname-directory path) (list (string-downcase dir)))
      #+:ccl-2 (append (pathname-directory path) (list dir))
      #+(and :ccl (not :ccl-2)) (concatenate 'string (pathname-directory path)
                         (string dir) ":")
      #-(or lucid :ccl) (configure-me-error)
    :defaults path))

(defun pop-directory (path)
  (make-pathname
    :directory
      #+(or lucid ccl-2) (butlast (pathname-directory path))
      #+(and :ccl (not :ccl-2)) (subseq (pathname-directory path) 0
             (position #\: (pathname-directory path) :from-end))
      #-(or lucid :ccl) (configure-me-error)
    :defaults path))

(defun canonical-pathname (path)
  #+(and lucid aix (not rios) (not ultrix))
  (let ((name (pathname-name path)))
    (cond ((stringp name)
       (when (> (length name) 11)
         (setq name (subseq name 0 11)))
       (when (some #'upper-case-p name)
         (setq name (string-downcase name)))
       (make-pathname :name name :defaults path))
      (t path)))
  #+(and lucid (or rios ultrix))
  (let ((name (pathname-name path)))
    (cond ((stringp name)
       (when (some #'upper-case-p name)
         (setq name (string-downcase name)))
       (make-pathname :name name :defaults path))
      (t path)))
  #+ccl-2
  (let ((name (pathname-name path)))
    (cond ((stringp name)
       (when (> (length name) 26)    ;31 - 5 for dot and extension
         (setq name (subseq name 0 26)))
       (make-pathname :name name :defaults path))
      (t path)))
  #+(not (or ccl-2
         (and lucid (or rios ultrix))
         (and lucid aix (not rios) (not ultrix))))
  (configure-me-error))




;;; ================================================================
;;;
;;;                Part the Second.
;;;
;;;
;;;      In which we define some code to make it easier to deal
;;;       with multiple, possibly mutually-dependent packages.
;;;
;;;
;;; ================================================================


;;; We use the pretty printer and condition system as described in CLtL2.
;;; These modules are not yet part of all Common Lisps, so install the
;;; public versions when necessary, and make them accessible via these two
;;; macros.

;;; Lisps with built-in pretty printers.
#+ccl nil

;;; Lisps without built-in pretty printers.
#+(or lucid (and :ccl (not ccl-2)))
(when (not (and (find-package "XP") (find-symbol "INSTALL" "XP")))
  (load (make-pathname
     :name "xp"
     :defaults (make-pathname :name nil :type nil
                  :defaults *load-pathname*))))

;;; Unconfigured lisps.
#-(or lucid :ccl) (configure-me-error)

(defmacro use-pretty-printer ()
  `(eval-when (:execute :load-toplevel :compile-toplevel)
     #+(or lucid (and :ccl (not ccl-2)))
     (eval `(,(find-symbol "INSTALL" "XP") :macro t))
     #+ccl-2 nil
     #-(or lucid :ccl) (configure-me-error)))

;;; Lisps with built-in condition systems.
#+(or lcl4.0 ccl-2) nil

;;; Lisps without built-in condition systems.
#+(or (and lucid (not lcl4.0))
      (and :ccl (not :ccl-2)))
(load (make-pathname
     :name "conditions"
     :defaults (make-pathname :name nil :type nil
                  :defaults *load-pathname*)))

;;; Unconfigured lisps.
#-(or lucid :ccl) (configure-me error)

(defmacro use-condition-system ()
  `(eval-when (eval load compile)
     #+(or lcl4.0 ccl-2) nil

     ;; Two step process.  I don't know of any lisps that have a built-in
     ;; pretty but no built-in condition system.
     #+(or (and lucid (not lcl4.0))
       (and :ccl (not :ccl-2)))
     (eval `(,(find-symbol "INSTALL" "XP") :macro t))
     #+(or (and lucid (not lcl4.0))
       (and :ccl (not :ccl-2)))
     (eval `(,(find-symbol "INSTALL" "CONDITIONS")))

     #-(or lucid :ccl) (configure-me-error)
    ))


;;; Packages every package wants to use.
(defparameter *base-packages*
  #+lucid '("LISP" "LUCID-COMMON-LISP" "DM")
  #-lucid '("COMMON-LISP" "DM"))

;;; Make a symbol accessible to _every_ package that uses package DM.
;;; Can be useful for debugging extensions.  It is tasteless to use this
;;; for code which is called non-interactively.
(defun global (syms)
  (unless (listp syms) (setq syms (list syms)))
  (dolist (sym syms)
    (import sym :dm)
    (export sym :dm))
  t)

;;; Define possibly mutually dependent packages.  This macro tears multiple
;;; package definitions apart and puts them back together again sideways.
;;; It arranges definitions so that first all packages are created, then
;;; the pretty printer and condition are made accessible to all packages as
;;; necessary, then symbols are shadowed in all packages, etc., etc., etc.
(defmacro define-packages (&rest pkg-defs)
  (labels ((intern-forms (strings package)
         (mapcar #'(lambda (string)
             `(intern ,string ,package))
             strings)))
    (do* ((defs pkg-defs (rest defs))
      (def (first defs) (first defs))
      (name (cadr (assoc :name def)) (cadr (assoc :name def)))
      (nicknames (rest (assoc :nicknames def))
             (rest (assoc :nicknames def)))
      (shadows (rest (assoc :shadow def))
           (rest (assoc :shadow def)))
      (shadowing-imports (rest (assoc :shadowing-import def))
                 (rest (assoc :shadowing-import def)))
      (exports (rest (assoc :export def))
           (rest (assoc :export def)))
      (globals (rest (assoc :global def))
           (rest (assoc :global def)))
      (uses (rest (assoc :use def))
        (rest (assoc :use def)))
      (imports (rest (assoc :import def))
           (rest (assoc :import def)))
      (make-forms nil)
      (xp-forms nil)
      (conditions-forms nil)
      (shadow-forms nil)
      (shadowing-import-forms nil)
      (export-forms nil)
      (global-forms nil)
      (use-forms nil)
      (import-forms nil)
      (warning-forms nil))
     ((endp defs)
      `(#-lucid progn
        ;; Lucid seems to evaluate calls to shadow at compile time,
        ;; even though SHADOW is not one of the functions listed on pp.
        ;; 685-691 as being required to be evaluated at compile time.
        #+lucid eval-when #+lucid (load eval)
        ,@make-forms
        ,@xp-forms
        ,@conditions-forms
        ,@shadow-forms
        ,@shadowing-import-forms
        ,@export-forms
        ,@global-forms
        ,@use-forms
        ,@import-forms
        ,@warning-forms))
      (push `(unless (find-package ,name)
           (make-package ,name
        :use ',*base-packages*
        ,@(when nicknames `(:nicknames ',nicknames))))
        make-forms)
      #+(or lucid ccl)
      (when (cadr (assoc :pretty-printing def))
    (push `(let ((*package* (find-package ,name)))
         (funcall (find-symbol "INSTALL" "XP") :macro t))
          xp-forms))
      #-(or lcl4.0 :ccl-2)
      (when (cadr (assoc :conditions def))
    (push `(let ((*package* (find-package ,name)))
         (funcall (find-symbol "INSTALL" "CONDITIONS") :macro t))
          conditions-forms))
      (when shadows
    (push `(shadow (list ,@(intern-forms shadows name)) ,name)
          shadow-forms))
      (when shadowing-imports
    (push `(shadowing-import
         (list ,@(mapcar
              #'(lambda (import-form)
                  `(find-symbol ,(first import-form)
                ,(second import-form)))
              shadowing-imports))
         ,name)
          shadowing-import-forms))
      (when exports
    (push `(export (list ,@(intern-forms exports name)) ,name)
          export-forms))
      (when globals
    (push `(let ((*package* (find-package ,name)))
         (funcall (find-symbol "GLOBAL" "ALLP")
              (list ,@(intern-forms globals name))))
          global-forms))
      (when uses
    (push `(use-package ',uses ,name) use-forms))
      (when imports
    (push `(import (list ,@(mapcar
                #'(lambda (import-form)
                    `(find-symbol ,(first import-form)
                          ,(second import-form)))
                imports))
               ,name)
          import-forms))
      (dolist (form def)
    (unless (member (car form)
            '(:name :nicknames :shadow :shadowing-import :export
              :global :use :import :pretty-printing :conditions))
      (push `(warn "Unknown keyword ~S in form ~S" ,(car form) ',form)
        warning-forms))))))

#||



;;; ================================================================
;;;
;;;                Part the Third.
;;;
;;;
;;;          In which we define the Dungeon Master.
;;;
;;;
;;; ================================================================

;;; The Dungeon Master is an extension of the module system described in
;;; Section 11.8 of CLtL1, but is incompatible with that system to the
;;; extent that it requires a one-to-one correspondence between modules and
;;; files.


;;; ================================================================
;;; The module search path.

(defvar *module-search-path* ())

(defun push-module-search-path (path)
  (setq path (pathname path))
  (when (pathname-name path)
    (cerror "Push ~A onto the search path anyway."
        "You probably don't want to push ~A
onto the module search path." (namestring path)))
  (pushnew path *module-search-path* :test #'equal))


;;; ================================================================
;;; Implementation-specific variables.

;;; For each implementation of Common Lisp, classify types of code
;;; according to types of dependency.  To load, compile, or execute code,
;;; it may be necessary to load or compile code which that code depends on,
;;; or to arrange for it to be loaded eventually.

;;; Actually, dependency types may vary within a lisp according to the
;;; current values of the qualities of the OPTIMIZE declaration.  However,
;;; since it is not possible to find out under what values a module was
;;; compiled, one must always assume the worst (= most preloading,
;;; reloading, precompiling, and recompiling).

;;; To configure a new lisp/architecture combination, refer to your
;;; configuration's documentation to discern what code dependencies it
;;; creates, or experiment with loading dependent code samples, and with
;;; compiling and disassembling them.

(defstruct (dm-keyword
         (:conc-name dmk-)
         (:constructor
          dmk
          (requires-preloading requires-precompiling incorporates-code
                   &rest keywords)))
  (keywords            ()    :type list)
  ;; Means "requires preloading in order to be loaded".
  (requires-preloading        nil    :type (member nil t))
  ;; Means "requires precompiling in order to be compiled inline".
  (requires-precompiling    nil    :type (member nil t))
  ;; E.g., macros and inline stuff.  Implies the previous two, plus
  ;; "requires reloading of dependent modules".
  (incorporates-code        nil    :type (member nil t)))

;;; The values given below were calculated for lisps compiling using the
;;; default OPTIMIZE qualities, NOT the worst-case (tightest code)
;;; optimization qualities.  Oops.

#+lucid
(defparameter *dm-keywords*
  (list
   (dmk nil  t   t  :constructors :accessors)
   (dmk  t   t   t  :modifiers)
   (dmk nil  t   t  :inline :inlines)
   (dmk  t  nil  t  :macros)
   (dmk  t  nil nil :toplevel-calls)
   (dmk  t  nil  t  :includes)        ; Includes structs in other structs.
   (dmk  t  nil nil :classes)        ; Uses classes as superclasses.
   (dmk  t  nil nil :specializers)    ; Uses types as specializers.
   (dmk  t  nil nil :types)        ; Declares types defined elsewhere
   (dmk  t  nil  t  :read-macros :reader-macros)))

#+vaxlisp
(defparameter *dm-keywords*
  (list
   (dmk nil  t   t  :accessors :modifiers)
   (dmk nil nil nil :constructors)
   (dmk nil  t   t  :inline :inlines)
   (dmk  t  nil  t  :macros)
   (dmk  t  nil nil :toplevel-calls)
   (dmk  t  nil  t  :includes)
   (dmk  t  nil nil :classes)
   (dmk  t  nil nil :specializers)
   (dmk  t  nil nil :types)        ; Declares types defined elsewhere
   (dmk  t  nil  t  :read-macros :reader-macros)))

#+:ccl
(defparameter *dm-keywords*
  (list
   (dmk nil nil  t  :accessors :modifiers)
   (dmk nil nil nil :constructors)
   (dmk nil nil nil :inline :inlines)
   (dmk  t  nil  t  :macros)
   (dmk  t  nil nil :toplevel-calls)
   (dmk  t  nil  t  :includes)
   (dmk  t  nil nil :classes)
   (dmk  t  nil nil :specializers)
   (dmk  t  nil nil :types)        ; Declares types defined elsewhere
   (dmk  t  nil  t  :read-macros :reader-macros)))

#-(or lucid vaxlisp :ccl)
(configure-me-error)

(defun valid-keyword-p (keyword)
  (dolist (dmk *dm-keywords* t)
    (when (member keyword (dmk-keywords dmk))
      (return t))))

(defun keywords-cross-p (keywords dmk)
  (declare (list keywords) (type dm-keyword dmk))
  (dolist (keyword keywords nil)
    (declare (keyword keyword))
    (dolist (dmk-keyword (dmk-keywords dmk))
      (declare (keyword dmk-keyword))
      (when (eq keyword dmk-keyword)
    (return-from keywords-cross-p t)))))

(defun incorporates-code-p (keywords)
  (declare (list keywords))
  (dolist (dmk *dm-keywords* nil)
    (declare (type dm-keyword dmk))
    (when (and (dmk-incorporates-code dmk)
           (keywords-cross-p keywords dmk))
      (return t))))

(defun requires-preloading-p (keywords)
  (declare (list keywords))
  (dolist (dmk *dm-keywords* nil)
    (declare (type dm-keyword dmk))
    (when (and (dmk-requires-preloading dmk)
           (keywords-cross-p keywords dmk))
      (return t))))

(defun requires-precompiling-p (keywords)
  (declare (list keywords))
  (dolist (dmk *dm-keywords* nil)
    (declare (type dm-keyword dmk))
    (when (and (dmk-requires-precompiling dmk)
           (keywords-cross-p keywords dmk))
      (return t))))


;;; ================================================================
;;; Information about files.

(defvar *empty-pathname* (make-pathname))

(defun file-compilation-status (file)
  (let ((lsp-file (make-pathname :type *lsp-type* :defaults file))
    (fas-file (make-pathname :type *fas-type* :defaults file)))
    (declare (pathname lsp-file fas-file))
    (let ((lsp-date (file-write-date lsp-file))
      (fas-date (file-write-date fas-file)))
      (declare (type (or null integer) lsp-date fas-date))
      (cond ((not lsp-date)
         (cond ((not fas-date)
            (values nil nil nil))
           (t
            (values :fas-only nil fas-file))))
        ((not fas-date)
         (values :lsp-only lsp-file nil))
        ((>= fas-date lsp-date)
         (values :fas-most-recent lsp-file fas-file))
        (t
         (values :lsp-most-recent lsp-file fas-file))))))

(defun find-appropriate-version (file)
  (cond ((pathname-type file)
     (probe-file file))
    (t
     (multiple-value-bind (status lsp-file fas-file)
         (file-compilation-status file)
       (if status
           (if (or (eq status :lsp-only) (eq status :lsp-most-recent))
           lsp-file
         fas-file))))))

(defun search-for-file (file &optional (search-path *module-search-path*))
  (dolist (library search-path
           (find-appropriate-version
            (merge-pathnames file *default-pathname-defaults*)))
    (let ((it (find-appropriate-version (merge-pathnames file library))))
      (if it (return it)))))


;;;============================================================================
;;; Information about modules.
;;;============================================================================

(defvar *module-table* (make-hash-table :test 'equal))
(defvar *modules-being-loaded* ())

(defstruct (module-info
         (:conc-name module-)
         (:constructor make-module (name))
         (:print-function print-module))
  (name            ""    :type string)
  ;; File loaded for that module, or NIL if not loaded
  (file            nil    :type (or null pathname))
  ;; Time when last load took place; if zero, module hasn't been successfully
  ;; loaded yet.
  (load-time        0    :type integer)
  ;; Whether or not the file should be compiled
  (compile-p        t    :type symbol)
  ;; Documentation string
  (doc            nil    :type (or null string))
  ;; Modules that this module is dependent on
  (dependencies        ()    :type list)
  )

(defun print-module (m &optional (s *standard-output*) l)
  (declare (ignore l))
  (format s "#<MODULE ~A>" (module-name m)))

(defun module (name)
  (cond ((module-info-p name)
     name)
    (t
     (setq name (string name))
     (or (gethash name *module-table*)
         (setf (gethash name *module-table*)
           (make-module name))))))

(defun module-loading-p (module)
  (member module *modules-being-loaded*))

(defun module-total-dependencies (module)
  (setq module (module module))
  (let ((result ()))
    (labels ((add-dependency (m)
           (unless (member m result)
         (push m result)
         (dolist (child (module-dependencies m))
           (add-dependency child)))))
      (dolist (d (module-dependencies module))
    (add-dependency d)))
    result))


;;;============================================================================
;;; Mapping modules to files.
;;;============================================================================

(defun find-module-file (module &optional file lsp-only (error-p t))

  (setq module (module module))
  (setq file (if file (pathname file) *empty-pathname*))

  ;; If the file has been loaded before, then push its pathname onto the search
  ;; path so that it will be tried first.
  (do ((search-path
    (if (module-file module)
        (cons (make-pathname
           :name (pathname-name (module-file module))
           :directory (pathname-directory (module-file module))
           :type nil
           :version nil)
          *module-search-path*)
      *module-search-path*))
       result)
      (())

    ;; This goes inside the loop so that when a file to be compiled isn't found
    ;; and the user specifies a new name, only lisp files will be considered.
    (when lsp-only
      (setq file (make-pathname :type *lsp-type* :defaults file)))

    ;; If the file doesn't have a filename yet, default to the name of the
    ;; module.
    (when (or (not (pathname-name file))
          (and (stringp (pathname-name file))
           (= (length (pathname-name file)) 0)))
      (setq file
        (canonical-pathname
          (make-pathname :name (module-name module)
                 :defaults file))))

    ;; Look for the file, and return it if found.
    (when (setq result (search-for-file file search-path))
      (return result))

    ;; Ask for a new filename, or return NIL if the user wants us to.
    (cond (error-p
       (cerror "Enter a new file name, or ignore the file."
           "File not found: ~A" (namestring file))
       (format *query-io* "New filename (return to ignore): ")
       (when (zerop (length (setq file (read-line *query-io*))))
         (return nil)))
      (t
       (return nil)))))

(defun uncompiled-modules ()
  (let ((result ()))
    (maphash #'(lambda (module-name module)
         (when (and (module-file module)
                (equal *lsp-type*
                   (pathname-type (module-file module))))
           (push module-name result)))
         *module-table*)
    result))

(defun intersects-p (a b)
  (declare (list a b))
  (dolist (a-item a nil)
    (when (member a-item b)
      (return t))))

(defun modules-dependent-on (&rest modules)
  (setq modules (mapcar #'module modules))
  (let ((result ()))
    (maphash #'(lambda (module-name module)
         (declare (ignore module-name))
         (when (intersects-p modules
                     (module-total-dependencies module))
           (push module result)))
         *module-table*)
    result))

;;;============================================================================
;;; Compiling files
;;;============================================================================

;;; The following goofiness handles recursive compiles.

(defvar *dm-files-being-compiled* nil)

(defun dm-compile-file (file)
  (cond (*dm-files-being-compiled*
     (unless
         (member file *dm-files-being-compiled* :test #'equal)
       (format t "~&DM: aborting compilation of ~A
    in order to compile ~A.~%"
           (namestring (first *dm-files-being-compiled*))
           (namestring file))
       (push file *dm-files-being-compiled*)
       (throw :precompile file)))
    (t
     (do ((*dm-files-being-compiled* (list file)))
         ((endp *dm-files-being-compiled*) t)
       (catch :precompile
         (when (catch :abort-compilation
             (let ((*package* (find-package "ALLP")))
               (compile-file (first *dm-files-being-compiled*)))
             nil)
           (warn "Compilation of ~A aborted."
             (namestring (first *dm-files-being-compiled*))))
         (pop *dm-files-being-compiled*))))))


;;;============================================================================
;;; Querying the user
;;;============================================================================

(defun query (choices format-string &rest format-args)
  (loop
   (fresh-line *query-io*)
   (apply #'format *query-io* format-string format-args)
   (format *query-io* " ~A " (mapcar #'second choices))
   (finish-output *query-io*)
   (let ((answer (read-one-char *query-io*)))
     (dolist (choice choices)
       (when (find answer (rest choice) :test #'char=)
     (return-from query (first choice)))))))

;;;============================================================================
;;; Loading and compiling individual modules
;;;============================================================================

(defvar *current-module* nil)
(defvar *module-provided-p* nil)
(defvar *unwind-protect*)

(defun module-needs-compiling-p (module path)
  (setq module (module module))
  (let ((file (find-module-file module path t)))
    (when file
      (multiple-value-bind (status lsp-file fas-file)
          (file-compilation-status file)
        (case status
          ((:lsp-only :lsp-most-recent)
       (format *query-io* "~2&")
       lsp-file)
      (:fas-most-recent
       (let ((changed-modules ()))
         (dolist (depend-mod (module-total-dependencies module))
           (let ((depend-file (find-module-file depend-mod nil t)))
         (when (and depend-file
                (> (file-write-date depend-file)
                   (file-write-date fas-file)))
           (push (module-name depend-mod) changed-modules))))
         (when changed-modules
           (apply #'format *query-io*
               "~2&~#[Nothing has changed.~;~
~A has changed.~;~
~A and ~A have changed.~:;~
~A,~@{~<~%~4T~14:;~#[~; and~] ~A~>~^,~} have changed.~]~%"
               changed-modules)
           lsp-file))))))))

(defun check-for-recompilation (module file)
  (setq module (module module))
  (when (equal (pathname-type file) *fas-type*)
    (dolist (depend-mod (module-total-dependencies module))
      (let ((depend-file (find-module-file depend-mod nil t)))
    (when (and depend-file
           (> (file-write-date depend-file)
              (file-write-date file)))
      (warn "DM: compiled version of module ~S is being loaded
    even though module ~S has been changed."
        (module-name module)
        (module-name depend-mod)))))))

(defvar *mload-verbose* t
  "Controls whether MLOAD prints messages as it loads files.")
(defvar *mload-print* nil
  "Controls whether MLOAD passes :PRINT T to LOAD as it loads files.")
(defvar *mload-depth* 0
  "How many mloads are currently in progress?")
(defvar *do-not-query*)
(defvar *inside-loop* nil)
(defvar *lisp-only* nil)

(defun mload (module &key (path nil) (force t) ((:print *mload-print*) *mload-print*) (query nil)
             (compile nil) (complete nil) (trace nil)
             ((:verbose *mload-verbose*) *mload-verbose*) (tag nil)
             ((:lisp-only *lisp-only*) *lisp-only*))
  #-(and lucid (not lcl4.0)) (declare (ignore trace))
  (setq module (module module))
  (when compile
    (mcomp module :path path :load nil :query query :force nil :tag tag))
  ;; The load time of a module is updated by PROVIDE-MODULE, but if the module
  ;; isn't successfully loaded, set it back to what it was before loading.
  (when (or force
        (and complete (module-loading-p module))
        (not (module-loading-p module)))
    (let ((old-load-time (module-load-time module))
      (old-module-dependencies (module-dependencies module))
      (loaded-successfully nil)
      (*current-module* module)
      (*unwind-protect* nil))
      (unwind-protect
      (let* ((file (find-module-file module path *lisp-only*))
         (file-write-date (file-write-date file)))
        (when (and file
               (or force
               (and complete (module-loading-p module))
               (> file-write-date (module-load-time module)))
               (or (not query)
               (ecase (query (if *inside-loop*
                         '((:yes #\y #\space)
                           (:no #\n #\rubout)
                           (:all #\a)
                           (:quit #\q))
                       '((:yes #\y #\space)
                         (:no #\n #\rubout)))
                     "Load ~A?" (namestring file))
                 (:yes t)
                 (:no nil)
                 (:all (setq *do-not-query* t) t)
                 (:quit (when tag (throw tag nil)) nil))))
          (check-for-recompilation module file)
          (let ((*mload-depth* (1+ *mload-depth*))
            (*modules-being-loaded*
              (cons module
                (if complete
                (list (first *modules-being-loaded*))
                  *modules-being-loaded*)))
            (*module-provided-p* nil))
        (when *mload-verbose*
          (format t "~&;~V@TLoading ~A...~%"
              *mload-depth* (enough-namestring file)))
        (setf (module-file module) file)
        (setf (module-dependencies module) ())
                (let ((*package* (find-package "ALLP")))
          (load file :print *mload-print* :verbose nil
            #+(and lucid (not lcl4.0)) :trace
            #+(and lucid (not lcl4.0)) trace))
        (setf (module-load-time module) file-write-date)
        (when *mload-verbose*
          (format t "~&;~V@TDone loading ~A~%"
              *mload-depth* (enough-namestring file)))
        (unless *module-provided-p*
          (cerror "Ignore the discrepancy"
              "The module ~A did not PROVIDE-MODULE itself"
              (module-name module)))))
        (setq loaded-successfully t))
    (when *unwind-protect*
      (funcall *unwind-protect*))
    (unless loaded-successfully
      (warn "Module ~S wasn't successfully loaded." (module-name module))
      (setf (module-load-time module) old-load-time)
      (setf (module-file module) nil)
      (setf (module-dependencies module) old-module-dependencies)))))
  (module-name module))

(defun mcomp (module &key (path nil) (load t) (force t) (query nil)
                 (print nil) (verbose *load-verbose*) (tag nil)
             (trace nil))
  (declare (special *do-not-query*))
  (setq module (module module))
  (cond
   ((module-compile-p module)
    (let ((file (if force
            (find-module-file module path t)
          (module-needs-compiling-p module path))))
      (cond
       ((and file
         (or (not query)
         (ecase (query (if *inside-loop*
                   '((:yes #\y #\space)
                     (:no #\n #\rubout)
                     (:all #\a)
                     (:quit #\q))
                 '((:yes #\y #\space)
                   (:no #\n #\rubout)))
                   "~A ~A?"
                   (ecase (file-compilation-status file)
                 ((:lsp-only :lsp-most-recent)
                  "Compile")
                 (:fas-most-recent
                  "Recompile"))
                   (namestring file))
           (:yes t)
           (:no nil)
           (:all (setq *do-not-query* t) t)
           (:quit (when tag (throw tag nil)) nil))))
    (let ((*current-module* module)
          (*unwind-protect* nil))
      (unwind-protect
          (dm-compile-file file)
        (when *unwind-protect*
          (funcall *unwind-protect*))))
    (when load
      (mload module :path path :compile nil :force t :print print
         :verbose verbose :query nil :trace trace)))
       (t
    (when load
      (mload module :path path :compile nil :force force :print print
         :verbose verbose :query query :trace trace)))))
    (module-name module))
   (t
    (if *current-module*
    (warn
"Module ~S wanted to compile module ~S, which should never be compiled."
      (module-name *current-module*)
      (module-name module))
      (warn
"Someone wanted to compile module ~S, which should never be compiled."
    (module-name module)))
    nil)))

(defmacro mload-protect (&body body)
  `(if (boundp '*unwind-protect*)
       (setq *unwind-protect* #'(lambda () ,@body))
     (warn "DM: MLOAD-PROTECT is being ignored because this module
    is not being loaded by MLOAD.")))


;;;============================================================================
;;; Loading and compiling multiple modules
;;;============================================================================

(defun include-exclude (i e)
  (cond ((null i)
     (maphash #'(lambda (key value)
              (declare (ignore key))
              (push value i))
          *module-table*))
    ((not (consp i)) (setq i (list i))))
  (unless (listp e) (setq e (list e)))
  (set-difference (mapcar #'module i) (mapcar #'module e)))

(defun load-modules (&key (include nil) (exclude nil)
              (compile nil)
              (force nil) ((:lisp-only *lisp-only*) *lisp-only*)
              (print nil) (verbose *load-verbose*)
              (query nil) (trace nil))
  (catch 'abort-loop
    (let ((*inside-loop* t)
      (*do-not-query* nil))
      (declare (special *do-not-query*))
      (dolist (mod (include-exclude include exclude))
    (mload mod
           :force force
           :print print
           :verbose verbose
           :compile compile
           :query (and query (not *do-not-query*))
           :tag 'abort-loop
           :trace trace
           :lisp-only *lisp-only*)))))

(defun compile-modules (&key (include nil) (exclude nil)
                 (load t) (force nil)
                 (print nil) (verbose *load-verbose*)
                 (query nil) (trace nil))
  (catch 'abort-loop
    (let ((*inside-loop* t)
      (*do-not-query* nil))
      (declare (special *do-not-query*))
      (dolist (mod (include-exclude include exclude))
    (when (module-compile-p mod)
      (mcomp mod
         :load load
         :force force
         :print print
         :verbose verbose
         :query (and query (not *do-not-query*))
         :tag 'abort-loop
         :trace trace))))))


;;;============================================================================
;;; Providing and requiring modules
;;;============================================================================

(defmacro provide-module (name &key (compile t) (documentation nil))
  `(progn
     (eval-when (eval load compile)
       (%define-module ,name ,compile ,documentation))
     (eval-when (eval)
       (%provide-module ,name 'eval))
     (eval-when (compile)
       (%provide-module ,name 'compile))
     (eval-when (load)
       (%provide-module ,name 'load))
     ,name))

(defun %define-module (module compile-p doc)
  (setq module (module module))
  (setf (module-compile-p module) compile-p)
  (setf (module-doc module) doc))

(defparameter *modules* nil)

(defun %provide-module (module type)
  (setq module (module module))
  (ecase type
    ((eval load)
     (pushnew (module-name module) *modules* :test #'string=)
     (cond ((eq module *current-module*)
        ;; It seems that we're being loaded by MLOAD, so we just
        ;; need to let MLOAD know that we've been loaded.
        (setq *module-provided-p* t))
       (t
        (when *current-module*
          (warn "The provide-module name ~S doesn't match
the require-module name ~S."
            (module-name module)
            (module-name *current-module*)))
        ;; We're not being loaded by MLOAD, so do the best job we
        ;; can to set the write date correctly.
        (setf (module-load-time module)
          (let ((file (find-module-file module nil nil nil)))
            (if file
            (file-write-date file)
              (get-universal-time)))))))
    (compile
     #-gclisp
     (unless (module-compile-p module)
       (warn "attempting to abort compilation of ~S" (module-name module))
       (throw :abort-compilation t))))
  module)

(defmacro require-module (module &rest keyword-args
                 &key path
                 (when t)
                 (eval :load)
                 (load :load)
                 (compile :load)
                 &allow-other-keys)
  (let ((keywords ()))
    (do* ((args keyword-args (cddr args))
      (keyword (first args) (first args))
      (value (second args) (second args)))
     ((endp args))
      (unless (member keyword '(:path :when :eval :load :compile))
    (if (valid-keyword-p keyword)
        (when value
          (pushnew keyword keywords))
      (warn "DM: Unknown keyword ~S ignored." keyword))))
    `(progn
       (eval-when (eval)
     (when ,when
       (%require-module ,module ,path ,eval 'eval ',keywords)))
       (eval-when (compile)
     (when ,when
       (%require-module ,module ,path ,compile 'compile ',keywords)))
       (eval-when (load)
     (when ,when
       (%require-module ,module ,path ,load 'load ',keywords)))
       ,module)))

(defun %require-module (module path action type keywords)
  (setq module (module module))
  (when *current-module*
    (if (incorporates-code-p keywords)
        (pushnew module (module-dependencies *current-module*))
      (setf (module-dependencies *current-module*)
      (delete module (module-dependencies *current-module*)))))
  (when action
    (mload module
       :path path
       :force nil
       :complete (requires-preloading-p keywords)
       :compile (and (eq type 'compile)
             (requires-precompiling-p keywords)))))

(defun unprovide-module (module)
  (setq module (module module))
  (remhash (module-name module) *module-table*)
  (setq *modules* (delete (module-name module) *modules* :test #'string=))
  (module-name module))